home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 3 / Gold Medal Software - Volume 3 (Gold Medal) (1994).iso / windows / editprog / newvisda.arj / VISDATA.BAS < prev    next >
Encoding:
BASIC Source File  |  1994-04-01  |  25.0 KB  |  957 lines
  1. '------------------------------------------------------------
  2. ' VISDATA.BAS
  3. ' support functions for the Visual Data sample application
  4. '
  5. ' General Information: This app is intended to demonstrate
  6. '   and exercise all of the functionality available in the
  7. '   VT (Virtual Table) Object layer in VB 3.0 Pro.
  8. '
  9. '   Any valid SQL statement may be sent via the Utility SQL
  10. '   function excluding "select" statements which may be
  11. '   executed from the Dynaset Create function. With these
  12. '   two features, this simple app becomes a powerful data
  13. '   definition and query tool accessing any ODBC driver
  14. '   available at the time.
  15. '
  16. '   The app has the capability to perform all DDL (data
  17. '   definition language) functions. These are accessed
  18. '   from the "Tables" form. This form accesses the
  19. '   "NewTable", "AddField" and "IndexAdd" forms to do
  20. '   the actual table, field and index definition.
  21. '   Tables and Indexes may be deleted when the corresponding
  22. '   "Delete" button is enabled. It is not possible to
  23. '   delete fields.
  24. '
  25. ' Naming Conventions:
  26. '   "f..."   = Form
  27. '   "c..."   = Form control
  28. '   "F..."   = Form level variable
  29. '   "gst..." = Global String
  30. '   "gf..."  = Global flag (true/false)
  31. '   "gw..."  = Global 2 byte integer value
  32. '
  33. '------------------------------------------------------------
  34.  
  35. Option Explicit
  36.  
  37. 'api declarations
  38. Declare Function OSGetPrivateProfileString% Lib "Kernel" Alias "GetPrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal ReturnString$, ByVal NumBytes As Integer, ByVal FileName$)
  39. Declare Function OSWritePrivateProfileString% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
  40. Declare Function OSGetWindowsDirectory% Lib "Kernel" Alias "GetWindowsDirectory" (ByVal a$, ByVal b%)
  41.  
  42. 'global object variables
  43. Global gCurrentDB As Database
  44. Global gfDBOpenFlag As Integer
  45. Global gCurrentDS As Dynaset
  46. Global gCurrentTbl As Table
  47. Global gCurrentQueryDef As querydef
  48. Global gCurrentField As Field
  49. Global gCurrentIndex As Index
  50. Global gTableListSS As Snapshot
  51.  
  52. 'global database variables
  53. Global gstDataType As String
  54. Global gstDBName As String
  55. Global gstUserName As String
  56. Global gstPassword As String
  57. Global gstDataBase As String
  58. Global gstDynaString As String
  59. Global gstTblName As String
  60. Global gfUpdatable As Integer
  61. Global glQueryTimeout As Long
  62. Global glLoginTimeout As Long
  63. Global gstTableDynaFilter As String
  64.  
  65. 'other global vars
  66. Global gstZoomData As String
  67. Global gwMaxGridRows As Long
  68.  
  69. 'new field properties
  70. Global gwFldType As Integer
  71. Global gwFldSize As Integer
  72. Global sumcolwid As Integer
  73.  
  74. 'global find values
  75. Global gfFindFailed As Integer
  76. Global gstFindExpr As String
  77. Global gstFindOp As String
  78. Global gstFindField As String
  79. Global gfFindMatch As Integer
  80. Global gfFromTableView As Integer
  81.  
  82. 'global filter variables
  83. Global FilterStr As String
  84.  
  85. ' Global sort variables
  86. Global Sortstr As String
  87.  
  88. 'global seek values
  89. Global gstSeekOperator As String
  90. Global gstSeekValue As String
  91.  
  92. 'global flags
  93. Global gfDBChanged As Integer
  94. Global gfFromSQL As Integer
  95. Global gfTransPending As Integer
  96. Global gfAddTableFlag As Integer
  97.  
  98. 'global constants
  99. Global Const DEFAULTDRIVER = "SQL Server"
  100. Global Const MODAL = 1
  101. Global Const HOURGLASS = 11
  102. Global Const DEFAULT_MOUSE = 0
  103. Global Const YES = 6
  104. Global Const MSGBOX_TYPE = 4 + 48 + 256
  105. Global Const TRUE_ST = "True"
  106. Global Const FALSE_ST = "False"
  107. Global Const EOF_ERR = 626
  108. Global Const FTBLS = 0
  109. Global Const FFLDS = 1
  110. Global Const FINDX = 2
  111. Global Const MAX_GRID_ROWS = 31999
  112. Global Const MAX_MEMO_SIZE = 20000
  113. Global Const GETCHUNK_CUTOFF = 50
  114.  
  115. 'field type constants
  116. Global Const FT_TRUEFALSE = 1
  117. Global Const FT_BYTE = 2
  118. Global Const FT_INTEGER = 3
  119. Global Const FT_LONG = 4
  120. Global Const FT_CURRENCY = 5
  121. Global Const FT_SINGLE = 6
  122. Global Const FT_DOUBLE = 7
  123. Global Const FT_DATETIME = 8
  124. Global Const FT_STRING = 10
  125. Global Const FT_BINARY = 11
  126. Global Const FT_MEMO = 12
  127.  
  128. 'table type constants
  129. Global Const DB_TABLE = 1
  130. Global Const DB_ATTACHEDTABLE = 6
  131. Global Const DB_ATTACHEDODBC = 4
  132. Global Const DB_QUERYDEF = 5
  133. Global Const DB_SYSTEMOBJECT = &H80000002
  134.  
  135. 'dynaset option parameter constants
  136. Global Const VBDA_DENYWRITE = &H1
  137. Global Const VBDA_DENYREAD = &H2
  138. Global Const VBDA_READONLY = &H4
  139. Global Const VBDA_APPENDONLY = &H8
  140. Global Const VBDA_INCONSISTENT = &H10
  141. Global Const VBDA_CONSISTENT = &H20
  142. Global Const VBDA_SQLPASSTHROUGH = &H40
  143.  
  144. 'db create/compact constants
  145. Global Const DB_CREATE_GENERAL = ";langid=0x0809;cp=1252;country=0"
  146. Global Const DB_VERSION10 = 1
  147.  
  148. ' Microsoft Access QueryDef types
  149. Global Const DB_QACTION = &HF0
  150. Global Const DB_QCROSSTAB = &H10
  151. Global Const DB_QDELETE = &H20
  152. Global Const DB_QUPDATE = &H30
  153. Global Const DB_QAPPEND = &H40
  154. Global Const DB_QMAKETABLE = &H50
  155.  
  156. ' Index Attributes
  157. Global Const DB_UNIQUE = 1
  158. Global Const DB_PRIMARY = 2
  159. Global Const DB_PROHIBITNULL = 4
  160. Global Const DB_IGNORENULL = 8
  161. Global Const DB_DESCENDING = 1  'For each field in Index
  162.  
  163. Function ActionQueryType (qn As String) As String
  164.   Dim i As Integer
  165.  
  166.   gTableListSS.MoveFirst
  167.   While gTableListSS.EOF = False And gTableListSS!Name <> qn
  168.     gTableListSS.MoveNext
  169.   Wend
  170.   If gTableListSS!Name = qn Then
  171.     Select Case gTableListSS!Attributes
  172.       Case DB_QCROSSTAB
  173.         ActionQueryType = "Cross Tab"
  174.       Case DB_QDELETE
  175.         ActionQueryType = "Delete"
  176.       Case DB_QUPDATE
  177.         ActionQueryType = "Update"
  178.       Case DB_QAPPEND
  179.         ActionQueryType = "Append"
  180.       Case DB_QMAKETABLE
  181.         ActionQueryType = "Make Table"
  182.     End Select
  183.   Else
  184.     ActionQueryType = ""
  185.   End If
  186.  
  187. End Function
  188.  
  189. Function CheckTransPending (msg As String) As Integer
  190.  
  191.   If gfTransPending = True Then
  192.     MsgBox msg + Chr(13) + Chr(10) + "Execute Commit or Rollback First.", 48
  193.     CheckTransPending = True
  194.   Else
  195.     CheckTransPending = False
  196.   End If
  197.  
  198. End Function
  199.  
  200. Sub CloseAllDynasets ()
  201.   Dim i As Integer
  202.  
  203.   MsgBar "Closing Dynasets", True
  204.   While i < forms.Count
  205.     If forms(i).Tag = "Dynaset" Then
  206.       Unload forms(i)
  207.     Else
  208.       i = i + 1
  209.     End If
  210.   Wend
  211.   MsgBar "", False
  212.  
  213. End Sub
  214.  
  215. Function CopyData (from_db As Database, to_db As Database, from_nm As String, to_nm As String) As Integer
  216.   On Error GoTo CopyErr
  217.  
  218.   Dim ds1 As Dynaset, ds2 As Dynaset
  219.   Dim i As Integer
  220.  
  221.   Set ds1 = from_db.CreateDynaset(from_nm)
  222.   Set ds2 = to_db.CreateDynaset(to_nm)
  223.  
  224.   While ds1.EOF = False
  225.     ds2.AddNew
  226.     For i = 0 To ds1.Fields.Count - 1
  227.       ds2(i) = ds1(i)
  228.     Next
  229.     ds2.Update
  230.     ds1.MoveNext
  231.   Wend
  232.  
  233.   CopyData = True
  234.   GoTo CopyEnd
  235.  
  236. CopyErr:
  237.   ShowError
  238.   CopyData = False
  239.   Resume CopyEnd
  240.  
  241. CopyEnd:
  242.  
  243. End Function
  244.  
  245. Function CopyStruct (from_db As Database, to_db As Database, from_nm As String, to_nm As String, create_ind As Integer) As Integer
  246.   On Error GoTo CSErr
  247.  
  248.   Dim i As Integer
  249.   Dim tbl As New Tabledef    'table object
  250.   Dim fld As Field           'field object
  251.   Dim ind As Index           'index object
  252.  
  253.   'search to see if table exists
  254. namesearch:
  255.   For i = 0 To to_db.TableDefs.Count - 1
  256.     If UCase(to_db.TableDefs(i).Name) = UCase(to_nm) Then
  257.       If MsgBox(to_nm + " already exists, delete it?", 4) = YES Then
  258.          to_db.TableDefs.Delete to_db.TableDefs(to_nm)
  259.       Else
  260.          to_nm = InputBox("Enter New Table Name:")
  261.          If to_nm = "" Then
  262.            Exit Function
  263.          Else
  264.            GoTo namesearch
  265.          End If
  266.       End If
  267.       Exit For
  268.     End If
  269.   Next
  270.  
  271.   'strip off owner if needed
  272.   If InStr(to_nm, ".") <> 0 Then
  273.     to_nm = Mid(to_nm, InStr(to_nm, ".") + 1, Len(to_nm))
  274.   End If
  275.   tbl.Name = to_nm
  276.  
  277.   'create the fields
  278.   For i = 0 To from_db.TableDefs(from_nm).Fields.Count - 1
  279.     Set fld = New Field
  280.     fld.Name = from_db.TableDefs(from_nm).Fields(i).Name
  281.     fld.Type = from_db.TableDefs(from_nm).Fields(i).Type
  282.     fld.Size = from_db.TableDefs(from_nm).Fields(i).Size
  283.     fld.Attributes = from_db.TableDefs(from_nm).Fields(i).Attributes
  284.     tbl.Fields.Append fld
  285.   Next
  286.  
  287.   'create the indexes
  288.   If create_ind <> False Then
  289.     For i = 0 To from_db.TableDefs(from_nm).Indexes.Count - 1
  290.       Set ind = New Index
  291.       ind.Name = from_db.TableDefs(from_nm).Indexes(i).Name
  292.       ind.Fields = from_db.TableDefs(from_nm).Indexes(i).Fields
  293.       ind.Unique = from_db.TableDefs(from_nm).Indexes(i).Unique
  294.       If gstDataType <> "ODBC" Then
  295.         ind.Primary = from_db.TableDefs(from_nm).Indexes(i).Primary
  296.       End If
  297.       tbl.Indexes.Append ind
  298.     Next
  299.   End If
  300.  
  301.   'append the new table
  302.   to_db.TableDefs.Append tbl
  303.  
  304.   CopyStruct = True
  305.   GoTo CSEnd
  306.  
  307. CSErr:
  308.   ShowError
  309.   CopyStruct = False
  310.   Resume CSEnd
  311.  
  312. CSEnd:
  313.  
  314. End Function
  315.  
  316. 'sub used to create a sample table and fill it
  317. 'with NumbRecs number of rows
  318. 'can only be called from the debug window
  319. 'for example:
  320. 'CreateSampleTable "mytbl",100
  321. Sub CreateSampleTable (TblName As String, NumbRecs As Long)
  322.   Dim ds As Dynaset
  323.   Dim ii As Long
  324.   Dim t1 As New Tabledef
  325.   Dim f1 As New Field
  326.   Dim f2 As New Field
  327.   Dim f3 As New Field
  328.   Dim f4 As New Field
  329.   Dim i1 As New Index
  330.   Dim i2 As New Index
  331.  
  332.   'create the data holding table
  333.   t1.Name = TblName
  334.   
  335.   f1.Name = "name"
  336.   f1.Type = FT_STRING
  337.   f1.Size = 25
  338.   t1.Fields.Append f1
  339.  
  340.   f2.Name = "address"
  341.   f2.Type = FT_STRING
  342.   f2.Size = 25
  343.   t1.Fields.Append f2
  344.  
  345.   f3.Name = "record"
  346.   f3.Type = FT_STRING
  347.   f3.Size = 10
  348.   t1.Fields.Append f3
  349.  
  350.   f4.Name = "id"
  351.   f4.Type = FT_LONG
  352.   f4.Size = 4
  353.   t1.Fields.Append f4
  354.  
  355.   gCurrentDB.TableDefs.Append t1
  356.  
  357.   'add the indexes
  358.   i1.Name = TblName + "1"
  359.   i1.Fields = "name"
  360.   i1.Unique = False
  361.   gCurrentDB.TableDefs(TblName).Indexes.Append i1
  362.  
  363.   i2.Name = TblName + "2"
  364.   i2.Fields = "id"
  365.   i2.Unique = True
  366.   gCurrentDB.TableDefs(TblName).Indexes.Append i2
  367.  
  368.   'add records to the table in reverse order
  369.   'so indexes have some work to do
  370.   Set ds = gCurrentDB.CreateDynaset(TblName)
  371.   For ii = NumbRecs To 1 Step -1
  372.     ds.AddNew
  373.     ds(0) = "name" + CStr(ii)
  374.     ds(1) = "addr" + CStr(ii)
  375.     ds(2) = "rec" + CStr(ii)
  376.     ds(3) = ii
  377.     ds.Update
  378.   Next
  379.  
  380. End Sub
  381.  
  382. Sub DisAbleAllButs ()
  383.     fQuery!RunQueryButton.Enabled = False
  384.     fQuery!GetValuesButton.Enabled = False
  385.     fQuery!ANDButton.Enabled = False
  386.     fQuery!ClearButton.Enabled = False
  387.     fQuery!CopySQLButton.Enabled = False
  388.     fQuery!JoinButton.Enabled = False
  389.     fQuery!ORButton.Enabled = False
  390.     fQuery!ShowSQLButton.Enabled = False
  391.     fQuery!cCriteria.Enabled = False
  392.     fQuery!cField.Enabled = False
  393.     fQuery!cValue.Enabled = False
  394.     fQuery!cGroupByField.Enabled = False
  395.     fQuery!cOrderByField.Enabled = False
  396.     fQuery!cJoinFields.Enabled = False
  397.     fQuery!cOperator.Enabled = False
  398.  
  399.  
  400. End Sub
  401.  
  402. Sub EnableAllButs ()
  403.     fQuery!RunQueryButton.Enabled = True
  404.     fQuery!GetValuesButton.Enabled = True
  405.     fQuery!ANDButton.Enabled = True
  406.     fQuery!ClearButton.Enabled = True
  407.     fQuery!CopySQLButton.Enabled = True
  408.     fQuery!JoinButton.Enabled = True
  409.     fQuery!ORButton.Enabled = True
  410.     fQuery!ShowSQLButton.Enabled = True
  411.     fQuery!cCriteria.Enabled = True
  412.     fQuery!cField.Enabled = True
  413.     fQuery!cValue.Enabled = True
  414.     fQuery!cGroupByField.Enabled = True
  415.     fQuery!cOrderByField.Enabled = True
  416.     fQuery!cJoinFields.Enabled = True
  417.     fQuery!cOperator.Enabled = True
  418.  
  419.  
  420. End Sub
  421.  
  422. Function GetFieldType (ft As String) As Integer
  423.   'return field length
  424.   If ft = "String" Then
  425.     GetFieldType = FT_STRING
  426.   Else
  427.     Select Case ft
  428.       Case "Counter"
  429.         GetFieldType = FT_LONG
  430.       Case "True/False"
  431.         GetFieldType = FT_TRUEFALSE
  432.       Case "Byte"
  433.         GetFieldType = FT_BYTE
  434.       Case "Integer"
  435.         GetFieldType = FT_INTEGER
  436.       Case "Long"
  437.         GetFieldType = FT_LONG
  438.       Case "Currency"
  439.         GetFieldType = FT_CURRENCY
  440.       Case "Single"
  441.         GetFieldType = FT_SINGLE
  442.       Case "Double"
  443.         GetFieldType = FT_DOUBLE
  444.       Case "Date/Time"
  445.         GetFieldType = FT_DATETIME
  446.       Case "Binary"
  447.         GetFieldType = FT_BINARY
  448.       Case "Memo"
  449.         GetFieldType = FT_MEMO
  450.     End Select
  451.   End If
  452.  
  453. End Function
  454.  
  455. Function GetFieldWidth (t As Integer)
  456.   'determines the form control width
  457.   'based on the field type
  458.   Select Case t
  459.     Case FT_TRUEFALSE
  460.       GetFieldWidth = 850
  461.     Case FT_BYTE
  462.       GetFieldWidth = 650
  463.     Case FT_INTEGER
  464.       GetFieldWidth = 900
  465.     Case FT_LONG
  466.       GetFieldWidth = 1100
  467.     Case FT_CURRENCY
  468.       GetFieldWidth = 1800
  469.     Case FT_SINGLE
  470.       GetFieldWidth = 1800
  471.     Case FT_DOUBLE
  472.       GetFieldWidth = 2200
  473.     Case FT_DATETIME
  474.       GetFieldWidth = 2000
  475.     Case FT_STRING
  476.       GetFieldWidth = 3250
  477.     Case FT_BINARY
  478.       GetFieldWidth = 3250
  479.     Case FT_MEMO
  480.       GetFieldWidth = 3250
  481.     Case Else
  482.       GetFieldWidth = 3250
  483.   End Select
  484.  
  485. End Function
  486.  
  487. Function GetINIString$ (ByVal szItem$, ByVal szDefault$)
  488.   Dim tmp As String
  489.   Dim x As Integer
  490.  
  491.   tmp = String$(2048, 32)
  492.   x = OSGetPrivateProfileString("VISDATA", szItem$, szDefault$, tmp, Len(tmp), "VISDATA.INI")
  493.  
  494.   GetINIString = Mid$(tmp, 1, x)
  495. End Function
  496.  
  497. Function GetNumbRecs (FDS As Dynaset) As Long
  498.   Dim ds As Dynaset
  499.  
  500.   On Error GoTo GNRErr
  501.  
  502.   Set ds = FDS.Clone()
  503.   If Not ds.EOF Then ds.MoveLast
  504.   GetNumbRecs = ds.RecordCount
  505.   ds.Close
  506.   If FDS.Updatable = True Then
  507.     gfUpdatable = True
  508.   End If
  509.  
  510.   GoTo GNREnd
  511.  
  512. GNRErr:
  513.   'just return because row count is non critical
  514.   GetNumbRecs = -1
  515.   Resume GNREnd
  516.  
  517. GNREnd:
  518.  
  519. End Function
  520.  
  521. Function GetNumbRecsSS (FDS As Snapshot) As Long
  522.   Dim ds As Snapshot
  523.  
  524.   On Error GoTo GNRSSErr
  525.  
  526.   Set ds = FDS.Clone()
  527.   If Not ds.EOF Then ds.MoveLast
  528.   GetNumbRecsSS = ds.RecordCount
  529.   ds.Close
  530.   If FDS.Updatable = True Then
  531.     gfUpdatable = True
  532.   End If
  533.  
  534.   GoTo GNRSSEnd
  535.  
  536. GNRSSErr:
  537.   'just return because row count is non critical
  538.   GetNumbRecsSS = -1
  539.   Resume GNRSSEnd
  540.  
  541. GNRSSEnd:
  542.  
  543. End Function
  544.  
  545. Function GetNumbRecsTbl (tbl As Table) As Long
  546.   Dim tbl2 As Table
  547.  
  548.   On Error GoTo GNRTErr
  549.  
  550.   Set tbl2 = tbl.Clone()
  551.   If Not tbl2.EOF Then tbl2.MoveLast
  552.   GetNumbRecsTbl = tbl2.RecordCount
  553.   tbl2.Close
  554.   gfUpdatable = True
  555.  
  556.   GoTo GNRTEnd
  557.  
  558. GNRTErr:
  559.   'just return because row count is non critical
  560.   GetNumbRecsTbl = -1
  561.   Resume GNRTEnd
  562.  
  563. GNRTEnd:
  564.  
  565. End Function
  566.  
  567. '----------------------------------------------------------------------------
  568. 'to use this function in any app,
  569. '1. create a form with a grid
  570. '2. create a dynaset
  571. '3. call this function from the form with
  572. '   grd    = your grid control name
  573. '   dynst$ = your dynaset open string (table name or SQL select statement)
  574. '   numb&  = the max number of rows to load (grid is limited to 2000)
  575. '   start& = starting row (needed to display the record number in the
  576. '            left column when loading blocks of records as the
  577. '            DynaGrid form in this app does with the "More" button)
  578. '----------------------------------------------------------------------------
  579. Function LoadGrid (grd As Control, FDS As Snapshot, dynst$, numb&, start&) As Integer
  580.    Dim ft As Integer               'field type
  581.    Dim i As Integer, j As Integer  'for loop indexes
  582.    Dim fn As String                'field name
  583.    Dim rc As Integer               'record count
  584.    Dim gs As String                'grid string
  585.  
  586.    On Error GoTo LGErr
  587.  
  588.    MsgBar "Loading Grid for Table View", True
  589.    'setup the grid
  590.    grd.Rows = 2       'reduce the grid
  591.    grd.FixedRows = 0  'allow next step
  592.    grd.Rows = 1       'clears the grid completely
  593.    grd.Cols = FDS.Fields.Count + 1
  594.  
  595.    If start& = 0 Then        'only do it on first call
  596.      On Error Resume Next
  597.      'set the column widths
  598.      For i = 0 To FDS.Fields.Count - 1
  599.        ft = FDS(i).Type
  600.        If ft = FT_STRING Then
  601.          If FDS(i).Size > Len(FDS(i).Name) Then
  602.            If FDS(i).Size <= 10 Then
  603.              grd.ColWidth(i + 1) = FDS(i).Size * fTables.TextWidth("A")
  604.            Else
  605.              grd.ColWidth(i + 1) = 10 * fTables.TextWidth("A")
  606.            End If
  607.          Else
  608.            If Len(FDS(i).Name) <= 10 Then
  609.              grd.ColWidth(i + 1) = Len(FDS(i).Name) * fTables.TextWidth("A")
  610.            Else
  611.              grd.ColWidth(i + 1) = 10 * fTables.TextWidth("A")
  612.            End If
  613.          End If
  614.        ElseIf ft = FT_MEMO Then
  615.          grd.ColWidth(i + 1) = 1200
  616.  
  617.        Else
  618.          grd.ColWidth(i + 1) = GetFieldWidth(ft)
  619.        End If
  620.        sumcolwid = sumcolwid + grd.ColWidth(i + 1)
  621.      Next
  622.  
  623.  
  624.      On Error GoTo LGErr
  625.      'load the field names
  626.      grd.Row = 0
  627.      For i = 0 To FDS.Fields.Count - 1
  628.        grd.Col = i + 1
  629.        grd.Text = UCase(FDS(i).Name)
  630.      Next
  631.    End If
  632.  
  633.    rc = 1
  634.  
  635.    'fill method 1
  636.    'add the rows with the additem method
  637.    While FDS.EOF = False And rc <= numb
  638.      gs = CStr(rc + start) + Chr$(9)
  639.      For i = 0 To FDS.Fields.Count - 1
  640.        If FDS(i).Type = FT_MEMO Then
  641.          If FDS(i).FieldSize() < 255 Then
  642.            gs = gs + StripNonAscii(vFieldVal(FDS(i))) + Chr$(9)
  643.          Else
  644.            'can only get the 1st 255 chars
  645.            gs = gs + StripNonAscii(vFieldVal(FDS(i).GetChunk(0, 255))) + Chr$(9)
  646.          End If
  647.        ElseIf FDS(i).Type = FT_STRING Then
  648.          gs = gs + StripNonAscii(vFieldVal(FDS(i))) + Chr$(9)
  649.        Else
  650.          gs = gs + vFieldVal(FDS(i)) + Chr$(9)
  651.        End If
  652.      Next
  653.      gs = Mid(gs, 1, Len(gs) - 1)
  654.      grd.AddItem gs
  655.      FDS.MoveNext
  656.      rc = rc + 1
  657.    Wend
  658.  
  659.    'fill method 2
  660.    'add the cells individually
  661. '   While fds.EOF = False And rc <= numb
  662. '     grd.Rows = rc + 1
  663. '     grd.Row = rc
  664. '     grd.Col = 0
  665. '     grd.Text = CStr(rc + start)
  666. '     For i = 0 To fds.Fields.Count - 1
  667. '       grd.Col = i + 1
  668. '       If fds(i).Type = FT_MEMO Then
  669. '         'can only get the 1st 255 chars
  670. '         grd.Text = StripNonAscii(vFieldVal((fds(i).GetChunk(0, 255))))
  671. '       ElseIf fds(i).Type = FT_STRING Then
  672. '         grd.Text = StripNonAscii(vFieldVal((fds(i))))
  673. '       Else
  674. '         grd.Text = CStr(vFieldVal(fds(i)))
  675. '       End If
  676. '     Next
  677. '     fds.MoveNext
  678. '     rc = rc + 1
  679. '   Wend
  680.  
  681.    grd.FixedRows = 1   'freeze the field names
  682.    grd.FixedCols = 1   'freeze the row numbers
  683.    grd.Row = 1         'set current position
  684.    grd.Col = 1
  685.  
  686.    LoadGrid = rc       'return number added
  687.    GoTo LGEnd
  688.  
  689. LGErr:
  690.    ShowError
  691.    LoadGrid = False    'return 0
  692.    Resume LGEnd
  693.  
  694. LGEnd:
  695.    MsgBar "", False
  696.  
  697. End Function
  698.  
  699. Sub MsgBar (msg As String, pw As Integer)
  700.   If msg = "" Then
  701.     VDMDI.cMsg = "Ready"
  702.   Else
  703.     If pw = True Then
  704.       VDMDI.cMsg = msg + ", please wait..."
  705.     Else
  706.       VDMDI.cMsg = msg
  707.     End If
  708.   End If
  709.   VDMDI.cMsg.Refresh
  710. End Sub
  711.  
  712. Sub Outlines (formname As Form)
  713.     Dim drkgray As Long, fullwhite As Long
  714.     Dim i As Integer
  715.     Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer
  716.  
  717.     ' Outline a form's controls for 3D look unless control's TAG
  718.     ' property is set to "skip".
  719.  
  720.     Dim cname As Control
  721.     drkgray = RGB(128, 128, 128)
  722.     fullwhite = RGB(255, 255, 255)
  723.  
  724.     For i = 0 To (formname.Controls.Count - 1)
  725.         Set cname = formname.Controls(i)
  726.         If TypeOf cname Is Menu Then
  727.             'Debug.Print "menu item"
  728.         ElseIf (UCase(cname.Tag) = "OL") Then
  729.                 ctop = cname.Top - screen.TwipsPerPixelY
  730.                 cleft = cname.Left - screen.TwipsPerPixelX
  731.                 cright = cname.Left + cname.Width
  732.                 cbottom = cname.Top + cname.Height
  733.                 formname.Line (cleft, ctop)-(cright, ctop), drkgray
  734.                 formname.Line (cleft, ctop)-(cleft, cbottom), drkgray
  735.                 formname.Line (cleft, cbottom)-(cright, cbottom), fullwhite
  736.                 formname.Line (cright, ctop)-(cright, cbottom), fullwhite
  737.         End If
  738.     Next i
  739. End Sub
  740.  
  741. Sub PicOutlines (pic As Control, ctl As Control)
  742.     Dim drkgray As Long, fullwhite As Long
  743.     Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer
  744.  
  745.     ' Outline a form's controls for 3D look unless control's TAG
  746.     ' property is set to "skip".
  747.  
  748.     Dim cname As Control
  749.     drkgray = RGB(128, 128, 128)
  750.     fullwhite = RGB(255, 255, 255)
  751.  
  752.     ctop = ctl.Top - screen.TwipsPerPixelY
  753.     cleft = ctl.Left - screen.TwipsPerPixelX
  754.     cright = ctl.Left + ctl.Width
  755.     cbottom = ctl.Top + ctl.Height
  756.     pic.Line (cleft, ctop)-(cright, ctop), drkgray
  757.     pic.Line (cleft, ctop)-(cleft, cbottom), drkgray
  758.     pic.Line (cleft, cbottom)-(cright, cbottom), fullwhite
  759.     pic.Line (cright, ctop)-(cright, cbottom), fullwhite
  760.  
  761. End Sub
  762.  
  763. Sub RefreshTables (tbl_list As Control, IncludeQueries As Integer)
  764.    Dim i As Integer, j As Integer, h As Integer
  765.    Dim st As String
  766.    Dim OkayToAdd As Integer
  767.  
  768.    On Error GoTo TRefErr
  769.  
  770.    MsgBar "Refreshing Table List", True
  771.    SetHourGlass VDMDI
  772.  
  773.    Set gTableListSS = gCurrentDB.ListTables()
  774.    tbl_list.Clear
  775.    IncludeQueries = False
  776.    If IncludeQueries And gstDataType = "MS Access" Then
  777.      ' the ListTables method is used to display querydefs that might
  778.      ' be present in an Access database, see below for optional code
  779.      While gTableListSS.EOF = False
  780.        st = gTableListSS!Name
  781.        If VDMDI.PrefAllowSys.Checked = False Then
  782.          If (gTableListSS!Attributes And DB_SYSTEMOBJECT) = 0 Then
  783.            tbl_list.AddItem st
  784.          End If
  785.        Else
  786.          tbl_list.AddItem st
  787.        End If
  788.        gTableListSS.MoveNext
  789.      Wend
  790.    Else
  791.      ' this method uses the tabledefs collection but will not display
  792.      ' querydefs in an Access database
  793.      tbl_list.Clear
  794.      For i = 0 To gCurrentDB.TableDefs.Count - 1
  795.        st = gCurrentDB.TableDefs(i).Name
  796.        If (gCurrentDB.TableDefs(i).Attributes And DB_SYSTEMOBJECT) = 0 Then
  797.          tbl_list.AddItem st
  798.        End If
  799.      Next
  800.    End If
  801.   
  802.    GoTo TRefEnd
  803.  
  804. TRefErr:
  805.    ShowError
  806.    gfDBOpenFlag = False
  807.    Resume TRefEnd
  808.  
  809. TRefEnd:
  810.    ResetMouse VDMDI
  811.    MsgBar "", False
  812.  
  813. End Sub
  814.  
  815. Sub ResetMouse (f As Form)
  816.   VDMDI.MousePointer = DEFAULT_MOUSE
  817.   f.MousePointer = DEFAULT_MOUSE
  818. End Sub
  819.  
  820. Function SetFldProperties (ft As String) As String
  821.   'return field length
  822.   If ft = "String" Then
  823.     gwFldType = FT_STRING
  824.   Else
  825.     Select Case ft
  826.       Case "Counter"
  827.         SetFldProperties = "4"
  828.         gwFldType = FT_LONG
  829.         gwFldSize = 4
  830.       Case "True/False"
  831.         SetFldProperties = "1"
  832.         gwFldType = FT_TRUEFALSE
  833.         gwFldSize = 1
  834.       Case "Byte"
  835.         SetFldProperties = "1"
  836.         gwFldType = FT_BYTE
  837.         gwFldSize = 1
  838.       Case "Integer"
  839.         SetFldProperties = "2"
  840.         gwFldType = FT_INTEGER
  841.         gwFldSize = 2
  842.       Case "Long"
  843.         SetFldProperties = "4"
  844.         gwFldType = FT_LONG
  845.         gwFldSize = 4
  846.       Case "Currency"
  847.         SetFldProperties = "8"
  848.         gwFldType = FT_CURRENCY
  849.         gwFldSize = 8
  850.       Case "Single"
  851.         SetFldProperties = "4"
  852.         gwFldType = FT_SINGLE
  853.         gwFldSize = 4
  854.       Case "Double"
  855.         SetFldProperties = "8"
  856.         gwFldType = FT_DOUBLE
  857.         gwFldSize = 8
  858.       Case "Date/Time"
  859.         SetFldProperties = "8"
  860.         gwFldType = FT_DATETIME
  861.         gwFldSize = 8
  862.       Case "Binary"
  863.         SetFldProperties = "0"
  864.         gwFldType = FT_BINARY
  865.         gwFldSize = 0
  866.       Case "Memo"
  867.         SetFldProperties = "0"
  868.         gwFldType = FT_MEMO
  869.         gwFldSize = 0
  870.     End Select
  871.   End If
  872. End Function
  873.  
  874. Sub SetHourGlass (f As Form)
  875.   DoEvents  'cause forms to repaint before going on
  876.   VDMDI.MousePointer = HOURGLASS
  877.   f.MousePointer = HOURGLASS
  878. End Sub
  879.  
  880. Sub ShowError ()
  881.   Dim s As String
  882.   Dim crlf As String
  883.  
  884.   crlf = Chr(13) + Chr(10)
  885.   s = "The following Error occurred:" + crlf + crlf
  886.   'add the error string
  887.   s = s + Error$ + crlf
  888.   'add the error number
  889.   s = s + "Number: " + CStr(Err)
  890.   'beep and show the error
  891.   Beep
  892.   MsgBox (s)
  893.  
  894. End Sub
  895.  
  896. Function StripFileName (fname As String) As String
  897.   On Error Resume Next
  898.   Dim i As Integer
  899.  
  900.   For i = Len(fname) To 1 Step -1
  901.     If Mid(fname, i, 1) = "\" Then
  902.       Exit For
  903.     End If
  904.   Next
  905.  
  906.   StripFileName = Mid(fname, 1, i - 1)
  907.  
  908. End Function
  909.  
  910. Function StripNonAscii (vs As Variant) As String
  911.   Dim i As Integer
  912.   Dim ts As String
  913.  
  914.   For i = 1 To Len(vs)
  915.     If Asc(Mid(vs, i, 1)) < 32 Or Asc(Mid(vs, i, 1)) > 126 Then
  916.       ts = ts + " "
  917.     Else
  918.       ts = ts + Mid(vs, i, 1)
  919.     End If
  920.   Next
  921.  
  922.   StripNonAscii = ts
  923.  
  924. End Function
  925.  
  926. Function stTrueFalse (tf As Variant) As String
  927.   If tf = True Then
  928.     stTrueFalse = "True"
  929.   Else
  930.     stTrueFalse = "False"
  931.   End If
  932. End Function
  933.  
  934. Function TableType (tbl As String) As Integer
  935.   Dim i As Integer
  936.  
  937.   gTableListSS.MoveFirst
  938.   While gTableListSS.EOF = False And gTableListSS!Name <> tbl
  939.     gTableListSS.MoveNext
  940.   Wend
  941.   If gTableListSS!Name = tbl Then
  942.     TableType = gTableListSS!TableType
  943.   Else
  944.     TableType = 0
  945.   End If
  946.  
  947. End Function
  948.  
  949. Function vFieldVal (fval As Variant) As Variant
  950.   If IsNull(fval) Then
  951.     vFieldVal = ""
  952.   Else
  953.     vFieldVal = CStr(fval)
  954.   End If
  955. End Function
  956.  
  957.